Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/gatekp.zip/GATEKPR2.PAS

Pascal/Delphi Source File | 1993-01-04 | 5KB | 239 lines

{$O+,F+}
unit gatekpr2;

(*                            Password Unit                                *)
{              Public Domain Coding By Remi Aubuchon, 1990                  }
{                         CompuServe # 71660,1016                                     }

interface

CONST
VCHAR = '*';                     {Character that will echo on screen}
DEFAULT_PASSWORD = 'NOPASSWORD'; {Will bypass Procedure}

TYPE
  PassString = string[10];

Function Encode(Str:PassString):PassString; {Gives back an encoded version of the password}
Function Decode(Str:PassString):PassString; {Gives back an decoded version of the password}
Procedure Gate_Keeper(PassKey:PassString);  {Checks Password}

implementation

USES
 Crt,WIN;

type

  TitleStrPtr = ^TitleStr;

  WinRecPtr = ^WinRec;
  WinRec = record
    Next: WinRecPtr;
    State: WinState;
    Title: TitleStrPtr;
    TitleAttr, FrameAttr: Byte;
    Buffer: Pointer;
  end;

var
  TopWindow: WinRecPtr;
  WindowCount: Integer;
  Done: Boolean;
  Ch: Char;
  Pass_Enter     : PassString;
  Gate_Count     : ShortInt;
  AOK            : BOOLEAN;

Function GetKey:CHAR;
var key: char;
begin
key := ReadKey;
If key = #0 then key := ReadKey; {If its a special function key}
GetKey := key;
end;

Procedure WriteAT(X,Y,F,B:BYTE;SayWhat:STRING);
begin
TextColor(F);
TextBackground(B);
GotoXY(X,Y);
Writeln(SayWhat);
end;

Procedure WriteCenter(y,f,b:BYTE;CntrString:STRING);
VAR
X:BYTE;
begin
X :=20-(LENGTH(CntrString) DIV 2);
WriteAT(x,y,f,b,CntrString);
end;

procedure OpenWindow(X1, Y1, X2, Y2: Byte; T: TitleStr;
  TAttr, FAttr: Byte);
var
  W: WinRecPtr;
begin
  New(W);
  with W^ do
  begin
    Next := TopWindow;
    SaveWin(State);
    GetMem(Title, Length(T) + 1);
    Title^ := T;
    TitleAttr := TAttr;
    FrameAttr := FAttr;
    Window(X1, Y1, X2, Y2);
    GetMem(Buffer, WinSize);
    ReadWin(Buffer^);
    FrameWin(T, DoubleFrame, TAttr, FAttr);
  end;
  TopWindow := W;
  Inc(WindowCount);
end;

procedure CloseWindow;
var
  W: WinRecPtr;
begin
  if TopWindow <> nil then
  begin
    W := TopWindow;
    with W^ do
    begin
      UnFrameWin;
      WriteWin(Buffer^);
      FreeMem(Buffer, WinSize);
      FreeMem(Title, Length(Title^) + 1);
      RestoreWin(State);
      TopWindow := Next;
    end;
    Dispose(W);
    Dec(WindowCount);
  end;
end;

Function Encode(Str:Passstring):Passstring;
var
  I : integer;
begin
    For I := 1 to 10 do
    begin
    CASE I OF
    1,3,5,7,9: Str[I] := chr(ord(Str[I]) + 5);
    2,4,6,8,10 : Str[I] := chr(ord(str[I])-5);
    end;
    end;
    Encode := Str;
end;

Function Decode(Str:Passstring):Passstring;
var
  I : integer;
begin
    For I := 1 to 10 do
    begin
    CASE I OF
    1,3,5,7,9: Str[I] := chr(ord(Str[I]) - 5);
    2,4,6,8,10 : Str[I] := chr(ord(str[I])+5);
    end;
    end;
    Decode := Str;
end;
PROCEDURE Process( VAR RawPass: PassString);
 CONST
 FillString = '          ';
 VAR
  i: INTEGER;

begin
  IF LENGTH (RawPass) < 10 THEN
     RawPass := RawPass +COPY(FillString,1,10-LENGTH(RawPass));
     FOR i := 1 to 10 DO
     If ord(RawPass[I]) in [97..122] then
           RawPass[I] := chr(ord(RawPass[I]) - 32);
end;

PROCEDURE Pass_Check(VAR Pass_Enter: PassString);
 VAR
  PCcount: BYTE;
  Ch: CHAR;

 BEGIN
  Pass_Enter := '';
  PCcount := 0;
  ClrScr;
  WriteAT(4, 3, Red, LightGray, 'Enter Password:');
  REPEAT
   GotoXY(20+PCcount,3);
   Ch := GetKey;
   IF ch <> #13 THEN
    BEGIN
     Pass_Enter := Pass_Enter + Ch;
     WriteAT(20 + PCcount, 3, Red, LightGray, Vchar);
     INC(PCcount);
    END
   ELSE
    BEGIN
     PCcount := 10;
    END;
  UNTIL PCcount = 10;
    Process(Pass_Enter);
 END;

PROCEDURE Gate_Keeper(Passkey: PassString);

 BEGIN
  IF Passkey <> DEFAULT_PASSWORD THEN
   BEGIN
    Process(Passkey);
    AOK := False;
    Gate_Count := 0;
    OpenWindow(20, 10, 60, 15, 'Password Required!',red, red);
    REPEAT
     Pass_Check(Pass_Enter);
     IF Pass_Enter <> PassKey THEN
    BEGIN
         ClrScr;
     WriteCenter(3, Red, black, 'Invalid Entry - Try Again!');
     Sound(700);
     Delay(200);
     NoSound;
     Delay(1000);
     Pass_Enter := '';
     INC(Gate_Count);
    END
     ELSE
    BEGIN
     Gate_Count := 2;
     AOK := True;
    END;
    UNTIL Gate_Count = 2;
    IF NOT AOK THEN
     BEGIN
    ClrScr;
    WriteCenter(3, Red, black, 'Entry - Denied!');
    Sound(100);
    Delay(300);
    NoSound;
    Delay(2000);
    CloseWindow;
        ClrScr;
    Halt(1); {That's it!}
     END
    ELSE
     BEGIN
        ClrScr;
    WriteCenter(3, white, black, 'Welcome!');
    Sound(1000);
    Delay(100);
    NoSound;
    Delay(2000);
    CloseWindow;
        TextColor(lightgray);
        TextBackground(black);
     END;
   END;
 END;

END.